library(DT)
library(glpkAPI)
library(irt)
library(irtoys)
library(ltm)
library(plink)
library(plyr)
library(psych)
library(reactable)
library(tidyverse)| 変数名 | 詳細 |
|---|---|
| ID | 受験者のID |
| Q1 〜 Q36 | 1番目から40番目の回答結果 (0 or 1) |
df_crr2 <- data.frame( # データフレーム名を指定(ここでは df_crr2 と指定)
item = names(crr2), # 変数名を指定(ここでは item と指定)
seikai = as.numeric(crr2) # 変数名を指定(ここでは seikai と指定)
) item seikai
1 Q1 0.7442922
2 Q2 0.8818182
3 Q3 0.8954545
4 Q4 0.3744076
5 Q5 0.4139535
6 Q6 0.5849057
7 Q7 0.8394495
8 Q8 0.5616438
9 Q9 0.5934579
10 Q10 0.4657534
11 Q11 0.2442396
12 Q12 0.5642202
13 Q13 0.5990783
14 Q14 0.2227273
15 Q15 0.9090909
16 Q16 0.8181818
17 Q17 0.3594470
18 Q18 0.7671233
19 Q19 0.5909091
20 Q20 0.6318182
21 Q21 0.7808219
22 Q22 0.7181818
23 Q23 0.1651376
24 Q24 0.2139535
25 Q25 0.3087558
26 Q26 0.3301887
27 Q27 0.9363636
28 Q28 0.9727273
29 Q29 0.9409091
30 Q30 0.3802817
31 Q31 0.7488584
32 Q32 0.3607306
33 Q33 0.8447489
34 Q34 0.9589041
35 Q35 0.8479263
36 Q36 0.8669725
ggplot(df_crr2, aes(x = seikai, y = item)) +
geom_bar(stat = "identity", fill = "skyblue") +
geom_text(aes(label = round(seikai, 2)), # 小数第2位で丸める
hjust = -0.2, size = 3) + # 棒の内側に表示
labs(
title = "各項目の正答率",
x = "項目",
y = "正答率"
) +
theme_minimal() +
theme_bw(base_family = "HiraKakuProN-W3") # 文字化け対策 正答率の計算のポイント
・極端に正答率の高い/低い項目があるかどうか
・極端に高い/低い項目がある場合 → 問題あり
・極端に高い/低い項目がない場合 → 問題なし
・ここでは次の項目をチェックする
→ 極端に高い項目(90%以上の正答率)・・・Q28〜Q3
→ 極端に低い項目(20%以下の正答率)・・・Q23
→ 次の分析に移る
cor()関数を使って、素点 (Q1 〜 Q36) と合計点 total
との相関を計算[1] 220 38
受験生は 220名
Q1・・・2列目
Q36・・・37列目
total・・・38列目
次の二つの相関を計算する
Q1(=2番目の項目)〜 Q36(=36番目の項目)
total(=37番目の項目)
total
Q1 0.29336063
Q2 0.33562403
Q3 0.28121742
Q4 0.51560591
Q5 0.19104289
Q6 0.26743612
Q7 0.28791771
Q8 0.15180953
Q9 0.42685694
Q10 0.37875091
Q11 0.14832979
Q12 0.34877935
Q13 0.22713900
Q14 0.22160121
Q15 0.42822127
Q16 0.29070948
Q17 0.34604474
Q18 0.42356302
Q19 0.40954602
Q20 0.57798397
Q21 0.40066530
Q22 0.41258493
Q23 0.01552610
Q24 0.09734145
Q25 0.02357517
Q26 0.22185973
Q27 0.29641284
Q28 0.29901267
Q29 0.17982935
Q30 0.26133634
Q31 0.42912820
Q32 0.27226490
Q33 0.35369579
Q34 0.18603293
Q35 0.28148011
Q36 0.32466814
# 行列をデータフレームに変換
df_it2 <- as.data.frame(it2)
# 行名を項目名として列に追加
df_it2$item <- rownames(df_it2)
# 列名をわかりやすく変更(オプション)
colnames(df_it2) <- c("correlation", "item")ggplot(df_it2, aes(x = correlation, y = item)) +
geom_bar(stat = "identity", fill = "orange") +
geom_text(aes(label = round(correlation, 3)),
hjust = -0.2, size = 3) +
xlim(0, 0.65) +
labs(
title = "項目-合計相関(item-total correlation)",
x = "項目",
y = "相関係数"
) +
theme_minimal() +
theme_bw(base_family = "HiraKakuProN-W3") # 文字化け対策 ・各項目への反応 (Q1 〜 Q36) と合計点 (total) との間にI-T 相関の度合いは妥当?
| IT相関値 | 評価 | 項目の扱い | 該当項目 |
| 〜 0.2 | 極めて低い(要注意) | 除外を検討する | Q5, Q25, Q24, Q11, Q8, Q29, Q34, Q5 |
| 0.2〜0.3 | やや低い | 内容によって再検討 | |
| 0.3〜0.4 | 妥当なレベル | 保留・文脈による判断 | |
| 0.4以上 | 良好(望ましい) | 採用して問題なし | Q20, Q4, Q31, Q15, Q9, Q18, Q22, Q19 |
→ ここでは0.2 以下の相関の項目が8つ → 除外を検討
psych::fa.parellel()library(psych)
data <- read.csv("data/irt_was.csv")
item_data <- data[, -1] # 一列目は分析に含めない
# 一次元性の検討(主成分+平行分析)
fa.parallel(item_data,
fa = "pc",
n.iter = 100) # 100回のシミュレーションを指定Parallel analysis suggests that the number of factors = NA and the number of components = 7
| 軸 | 示している内容 | 解釈のポイント |
| X軸 | 因子番号(主成分番号) | 因子1〜因子36 |
| Y軸 | 固有値(説明される分散量) | 1より大きい → 有意味な因子の可能性あり |
→ 固有値(Eigenvalue)
=>
主成分分析や因子分析において「その因子が説明するデータ全体の分散の量」を示す数値
→ 各因子がデータの分散をどれだけ説明しているかを表す指標
→ 固有値の値が大きいほど、その因子は多くの情報(=ばらつき、構造)をキャッチしており
→ その因子で、たくさんの項目のスコアをまとめて説明できるということ
| 線の色と種類 | 表す内容 | 解釈上の意味 |
| 青線 | 実データの固有値 | 実際の項目相関から得られた因子の強さ |
| 赤破線(細かい) | シミュレート | 完全にランダムなデータから得た固有値の平均 |
| 赤破線(やや太め) | リサンプル | 元データを再標本化した結果の固有値の平均 |
| 黒線 | 固有値=1 | 1より大きければ、有意味な因子の可能性あり |
分析結果
・実データの固有値が10次元以上でランダムを超える
・明確な多次元性あり(一次元モデルは不適)
| 対処法 | 説明 |
| ① 多次元IRT(MIRT)モデルの推定 | mirt(…, 2) や …, 3 などで2次元・3次元モデルを検討 |
| ② 因子分析(EFA)で項目を分類 | 似た因子に属する項目をまとめて、部分テストとしてIRTを適用 |
| ③ 次元を1つに統一するよう項目を精選 | 異なる内容の項目を削除・再構成して一次元性を確保 |
→ 項目パラメーター(「識別力a」と「困難度b」)と潜在特性値(学力θ)の推定へ
ここでは 2 パラメタ・ロジスティックモデル (2PL: 一般化ロジスティックモデル)を使って分析する
データフレーム df2 を確認
[1] 220 38
ex2 <- est(resp = df2[, 2:37], # テストデータを指定する引数
model = "2PL", # 2PLMを仮定
engine = "ltm") # ltmパッケージを利用して項目母数を推定すると指定
ex2$est
[,1] [,2] [,3]
Q1 0.83101563 -1.4837419 0
Q2 1.38529706 -1.8868385 0
Q3 0.96083273 -2.5781569 0
Q4 1.17398639 0.5348538 0
Q5 0.30308003 1.1720583 0
Q6 0.40541452 -0.8908177 0
Q7 0.84944311 -2.2112025 0
Q8 0.21668701 -1.1654871 0
Q9 1.02539301 -0.4665746 0
Q10 0.84664746 0.1589867 0
Q11 0.19059685 5.9706787 0
Q12 0.75312216 -0.4032208 0
Q13 0.08718103 -4.6166578 0
Q14 0.56079979 2.3682460 0
Q15 2.66234874 -1.5583871 0
Q16 0.99818390 -1.7964914 0
Q17 0.84008267 0.7663600 0
Q18 1.40381366 -1.1669284 0
Q19 0.48693593 -0.8133296 0
Q20 1.98871836 -0.4996180 0
Q21 1.35340407 -1.2622575 0
Q22 0.96305339 -1.1754989 0
Q23 -0.08172114 -19.8650474 0
Q24 0.03501333 37.1694908 0
Q25 -0.30777475 -2.6872822 0
Q26 0.02950535 23.9739215 0
Q27 1.55000393 -2.2765012 0
Q28 3.98038339 -1.9469339 0
Q29 0.76696232 -3.9245301 0
Q30 0.62852045 0.8365656 0
Q31 1.34152251 -1.1021836 0
Q32 0.15013542 3.8197754 0
Q33 1.08891672 -1.8915249 0
Q34 0.84665151 -4.0757930 0
Q35 0.79165359 -2.4259284 0
Q36 1.06302106 -2.1052554 0
$se
[,1] [,2] [,3]
[1,] 0.2338576 0.3801713 0
[2,] 0.3987228 0.3810303 0
[3,] 0.3385227 0.7379581 0
[4,] 0.2338250 0.1738089 0
[5,] 0.1607692 0.7590312 0
[6,] 0.1691979 0.4897666 0
[7,] 0.2761040 0.6118341 0
[8,] 0.1581844 1.0400471 0
[9,] 0.2280855 0.1751453 0
[10,] 0.1980058 0.1896641 0
[11,] 0.1786044 5.5714769 0
[12,] 0.1942374 0.2162077 0
[13,] 0.1614898 8.6640289 0
[14,] 0.1947492 0.7913817 0
[15,] 0.7785051 0.2066898 0
[16,] 0.2852876 0.4183951 0
[17,] 0.2002724 0.2464511 0
[18,] 0.3247702 0.2081203 0
[19,] 0.1829278 0.3981055 0
[20,] 0.4084806 0.1163234 0
[21,] 0.3245696 0.2318685 0
[22,] 0.2397270 0.2718255 0
[23,] 0.2078260 50.4074626 0
[24,] 0.1857672 197.1842928 0
[25,] 0.1780322 1.5581067 0
[26,] 0.1656170 134.6250212 0
[27,] 0.5180435 0.5006750 0
[28,] 1.8721125 0.2602029 0
[29,] 0.4029644 1.7995226 0
[30,] 0.1808207 0.3242469 0
[31,] 0.3129724 0.2088459 0
[32,] 0.1631607 4.2265221 0
[33,] 0.3145162 0.4288678 0
[34,] 0.4816135 1.9908538 0
[35,] 0.2748202 0.7268334 0
[36,] 0.3270586 0.5094791 0
$vcm
$vcm[[1]]
[,1] [,2]
[1,] 0.05468939 0.07445014
[2,] 0.07445014 0.14453019
$vcm[[2]]
[,1] [,2]
[1,] 0.1589799 0.1342853
[2,] 0.1342853 0.1451841
$vcm[[3]]
[,1] [,2]
[1,] 0.1145976 0.2352867
[2,] 0.2352867 0.5445822
$vcm[[4]]
[,1] [,2]
[1,] 0.05467412 -0.01872764
[2,] -0.01872764 0.03020952
$vcm[[5]]
[,1] [,2]
[1,] 0.02584675 -0.09621237
[2,] -0.09621237 0.57612836
$vcm[[6]]
[,1] [,2]
[1,] 0.02862794 0.05677026
[2,] 0.05677026 0.23987132
$vcm[[7]]
[,1] [,2]
[1,] 0.0762334 0.1558379
[2,] 0.1558379 0.3743410
$vcm[[8]]
[,1] [,2]
[1,] 0.0250223 0.1302215
[2,] 0.1302215 1.0816979
$vcm[[9]]
[,1] [,2]
[1,] 0.05202298 0.01415844
[2,] 0.01415844 0.03067586
$vcm[[10]]
[,1] [,2]
[1,] 0.039206302 -0.008202823
[2,] -0.008202823 0.035972456
$vcm[[11]]
[,1] [,2]
[1,] 0.03189952 -0.9838605
[2,] -0.98386055 31.0413548
$vcm[[12]]
[,1] [,2]
[1,] 0.03772815 0.01413777
[2,] 0.01413777 0.04674576
$vcm[[13]]
[,1] [,2]
[1,] 0.02607895 1.375339
[2,] 1.37533850 75.065397
$vcm[[14]]
[,1] [,2]
[1,] 0.03792726 -0.1421844
[2,] -0.14218437 0.6262850
$vcm[[15]]
[,1] [,2]
[1,] 0.6060702 0.12211463
[2,] 0.1221146 0.04272067
$vcm[[16]]
[,1] [,2]
[1,] 0.08138904 0.1051536
[2,] 0.10515363 0.1750545
$vcm[[17]]
[,1] [,2]
[1,] 0.04010902 -0.03053288
[2,] -0.03053288 0.06073814
$vcm[[18]]
[,1] [,2]
[1,] 0.10547568 0.04825235
[2,] 0.04825235 0.04331407
$vcm[[19]]
[,1] [,2]
[1,] 0.03346259 0.04856354
[2,] 0.04856354 0.15848797
$vcm[[20]]
[,1] [,2]
[1,] 0.16685640 0.01270551
[2,] 0.01270551 0.01353113
$vcm[[21]]
[,1] [,2]
[1,] 0.10534545 0.05702124
[2,] 0.05702124 0.05376299
$vcm[[22]]
[,1] [,2]
[1,] 0.05746904 0.04876296
[2,] 0.04876296 0.07388908
$vcm[[23]]
[,1] [,2]
[1,] 0.04319165 -10.46569
[2,] -10.46568747 2540.91229
$vcm[[24]]
[,1] [,2]
[1,] 0.03450945 -36.61974
[2,] -36.61973784 38881.64534
$vcm[[25]]
[,1] [,2]
[1,] 0.03169548 -0.2635148
[2,] -0.26351485 2.4276966
$vcm[[26]]
[,1] [,2]
[1,] 0.02742898 -22.28111
[2,] -22.28110624 18123.89632
$vcm[[27]]
[,1] [,2]
[1,] 0.2683691 0.2366886
[2,] 0.2366886 0.2506755
$vcm[[28]]
[,1] [,2]
[1,] 3.5048053 0.37991626
[2,] 0.3799163 0.06770557
$vcm[[29]]
[,1] [,2]
[1,] 0.1623803 0.708381
[2,] 0.7083810 3.238282
$vcm[[30]]
[,1] [,2]
[1,] 0.03269611 -0.03853284
[2,] -0.03853284 0.10513604
$vcm[[31]]
[,1] [,2]
[1,] 0.09795175 0.04634588
[2,] 0.04634588 0.04361663
$vcm[[32]]
[,1] [,2]
[1,] 0.02662141 -0.6722509
[2,] -0.67225093 17.8634891
$vcm[[33]]
[,1] [,2]
[1,] 0.09892042 0.1201392
[2,] 0.12013920 0.1839276
$vcm[[34]]
[,1] [,2]
[1,] 0.2319515 0.9379179
[2,] 0.9379179 3.9634987
$vcm[[35]]
[,1] [,2]
[1,] 0.07552614 0.1869027
[2,] 0.18690270 0.5282868
$vcm[[36]]
[,1] [,2]
[1,] 0.1069673 0.1518345
[2,] 0.1518345 0.2595690
plot(x = P2, # xは引数、irf関数で推定した結果を指定する
co = NA, # ICCの色を指定/項目毎に異なる色でICCを描く
label = TRUE) # 各ICCに項目の番号がつく
abline(v = 0, lty = 2) # x = 0 の縦点線を引く横軸・・・潜在特性値 \(θ\)
(Ability)
縦軸・・・正答確率 (Probability of a correct response)
-0.30777475・項目が能力をどれだけ区別できるかを示すパラメータ
適切な識別力 a の大きさ
0.3 〜
2.0
(出典:芝祐順編『項目反応理論』p.34)
library(irt)
library(ggplot2)
library(dplyr)
# モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 識別力(aパラメータ)を取り出す
discrimination <- ex2$est[, 1]
# データフレーム化
disc_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = discrimination
) %>%
arrange(Discrimination) %>%
mutate(Item = factor(Item, levels = Item)) # 並び順固定
# ラベルを左右に分けるため、hjust列を作成
disc_df <- disc_df %>%
mutate(
hjust_pos = ifelse(Item %in% c("Q23", "Q25"), 1.1, -0.1) # Q24とQ26だけ左側に、それ以外は右側に
)
# グラフ描画
ggplot(disc_df, aes(x = Discrimination, y = Item)) +
geom_bar(stat = "identity", fill = "steelblue") +
geom_text(
aes(label = round(Discrimination, 2), hjust = hjust_pos),
size = 3
) +
geom_vline(xintercept = 0.3, color = "red", linetype = "dashed", size = 0.5) +
geom_vline(xintercept = 2.0, color = "red", linetype = "dashed", size = 0.5) +
labs(
title = "識別力の大きさ順に並べた項目",
x = "識別力",
y = "項目"
) +
theme_minimal(base_family = "Hiragino Sans") +
coord_cartesian(xlim = c(min(disc_df$Discrimination) - 0.5, max(disc_df$Discrimination) + 0.5)) # 余白確保library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(a=識別力, b=困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # aパラメータ
Difficulty = ex2$est[, 2] # bパラメータ
)
# 3. 識別力が0.3以下の項目だけ抽出
low_disc_items <- param_df %>%
filter(Discrimination <= 0.3)
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(low_disc_items), function(i) {
a <- low_disc_items$Discrimination[i]
b <- low_disc_items$Difficulty[i]
item_name <- low_disc_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データ結合
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>% # θ = 4 の位置
ungroup()
# 8. ICC描画
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) + # ★ ここでy軸を0〜1に固定 ★
labs(
title = "識別力が0.3以下の項目のICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none") # 凡例を消してスッキリ識別力0.3以下の項目の評価
・識別力は、受験者のθ(能力)による正答確率の変化の鋭さを表す
・識別力が高いと → 能力の違いに敏感に反応する
→ θが少し上がるだけで正答率が大きく上がる
・識別力が低い(0.3以下)と
→ θが変わっても正答確率があまり変わらない=「区別がつかない」
・Q25の識別力は
-0.30777475
→ 識別力がマイナスの値 → 能力が高いほど正答率が低いということ
・識別力が小さくても、正答率が高ければ「基礎知識の確認問題」と位置づけて残すことも可能
・Q23とQ25・・・識別力がマイナス(異常値)なので除外
・Q32, Q11, Q26, Q24・・・識別力が小さので除外
・Q8とQ13・・・識別力が小さいが、正答率が比較的高いので「基礎知識の確認問題」として残すことも可能だが、基本的に除外
library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(a=識別力, b=困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # aパラメータ
Difficulty = ex2$est[, 2] # bパラメータ
)
# 3. 識別力が 0.2 以上の項目(=Q30 & Q15)だけ抽出
low_disc_items <- param_df %>%
filter(Discrimination > 2)
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(low_disc_items), function(i) {
a <- low_disc_items$Discrimination[i]
b <- low_disc_items$Difficulty[i]
item_name <- low_disc_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データ結合
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>% # θ = 4 の位置
ungroup()
# 8. ICC描画
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) + # ★ ここでy軸を0〜1に固定 ★
labs(
title = "Q28 (識別力 = 3.98) とQ15(識別力 = 2.66)のICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none") # 凡例を消してスッキリ識別力が高すぎる項目の評価
・識別力は、受験者のθ(能力)による正答確率の変化の鋭さを表す
・識別力が高いと → 能力の違いに敏感に反応する
→ θが少し上がるだけで正答率が大きく上がる
・Q28とQ15・・・識別力が異常値なので除外
library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(a=識別力, b=困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # aパラメータ
Difficulty = ex2$est[, 2] # bパラメータ
)
# 3. 識別力が0.3以上、2.0以下の項目だけ抽出
low_disc_items <- param_df %>%
filter(Discrimination > 0.3 & Discrimination < 2.0)
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(low_disc_items), function(i) {
a <- low_disc_items$Discrimination[i]
b <- low_disc_items$Difficulty[i]
item_name <- low_disc_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データ結合
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>% # θ = 4 の位置
ungroup()
# 8. ICC描画
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) + # ★ ここでy軸を0〜1に固定 ★
labs(
title = "適度な識別力項目 (0.3〜2.0) の ICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none") # 凡例を消してスッキリ適度な識別力項目 (0.3〜2.0) の評価
・θ(学力)が上がるにつれて正答確率がきちんと上昇
・学力がやや低い付近(−2 〜
0)で、正答確率がぐっと上がる項目が多い
・θが低い受験者と高い受験者で正答率に差が出る
→ つまり、能力をよく区別できる優れた項目群
| 識別力 | 評価 | 詳細 |
| 1.0〜2.0 | ◎ 非常に良い | 能力差を鋭く捉えられる(例:Q20〜Q16) |
library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(a=識別力, b=困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # aパラメータ
Difficulty = ex2$est[, 2] # bパラメータ
)
# 3. 16〜Q20だけ抽出
low_disc_items <- param_df %>%
filter(Item %in% c("Q20", "Q27", "Q18", "Q2", "Q21", "Q31", "Q4", "Q33", "Q36", "Q9", "Q16"))
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 400)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(low_disc_items), function(i) {
a <- low_disc_items$Discrimination[i]
b <- low_disc_items$Difficulty[i]
item_name <- low_disc_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データ結合
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成(θ=-1付近)
label_positions <- icc_long %>%
group_by(Item) %>%
filter(abs(theta - (-1)) == min(abs(theta - (-1)))) %>% # θ = -1に最も近い点を取る
ungroup()
# 8. ICC描画
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
vjust = -0.8, # 少し上にずらして「曲線の上」に配置
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) +
labs(
title = "指定項目 (θ=-1あたりに項目ラベル)",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none")| 識別力 | 評価 | 詳細 |
| 0.6〜1.0 | ○ 良い | 標準的な能力測定ができる(Q22〜Q30) |
library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(a=識別力, b=困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # aパラメータ
Difficulty = ex2$est[, 2] # bパラメータ
)
# 3. Q1, Q3, Q7, Q10, Q12だけ抽出
low_disc_items <- param_df %>%
filter(Item %in% c("Q22", "Q3", "Q7", "Q34", "Q10", "Q17", "Q1", "Q35", "Q29", "Q12", "Q30"))
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(low_disc_items), function(i) {
a <- low_disc_items$Discrimination[i]
b <- low_disc_items$Difficulty[i]
item_name <- low_disc_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データ結合
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>%
ungroup()
# 8. ICC描画
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) +
labs(
title = "指定項目 (Q23〜Q32) の ICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none")| 識別力 | 評価 | 詳細 |
| 0.3〜0.6 | △ 許容範囲 | 使えるが改善を検討(Q14〜Q5) |
library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(a=識別力, b=困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # aパラメータ
Difficulty = ex2$est[, 2] # bパラメータ
)
# 3. Q5, Q6, Q14, Q19, Q32だけ抽出
low_disc_items <- param_df %>%
filter(Item %in% c("Q14", "Q19", "Q6", "Q5"))
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(low_disc_items), function(i) {
a <- low_disc_items$Discrimination[i]
b <- low_disc_items$Difficulty[i]
item_name <- low_disc_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データ結合
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>%
ungroup()
# 8. ICC描画
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) +
labs(
title = "指定項目 (Q14〜Q5) の ICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none")| 識別力 | 評価 | 詳細 |
| 0.3以下 | × 削除すべき | 推定不可(Q8〜Q25) |
library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(a=識別力, b=困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # aパラメータ
Difficulty = ex2$est[, 2] # bパラメータ
)
# 3. Q5, Q6, Q14, Q19, Q32だけ抽出
low_disc_items <- param_df %>%
filter(Item %in% c("Q8", "Q11", "Q32", "Q13", "Q24", "Q26", "Q23", "Q25"))
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(low_disc_items), function(i) {
a <- low_disc_items$Discrimination[i]
b <- low_disc_items$Difficulty[i]
item_name <- low_disc_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データ結合
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>%
ungroup()
# 8. ICC描画
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) +
labs(
title = "指定項目 (Q8〜Q25) の ICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none")適切な困難力 b の大きさ
−3 〜 3
(出典:芝祐順編『項目反応理論』p.34)
library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出
difficulty_df <- data.frame(
Item = rownames(ex2$est),
Difficulty = ex2$est[, 2]
)
# 3. 困難度で並べ替え(昇順)
difficulty_df <- difficulty_df %>%
arrange(Difficulty) %>%
mutate(Item = factor(Item, levels = Item)) # 項目順を固定する
# 4. ラベル位置を調整(棒の先に表示するため)
difficulty_df <- difficulty_df %>%
mutate(label_position = ifelse(Difficulty >= 0, Difficulty + 0.2, Difficulty - 0.2))
# 5. プロット
ggplot(difficulty_df, aes(x = Difficulty, y = Item)) +
geom_bar(stat = "identity", aes(fill = Difficulty > 0), width = 0.6) +
geom_text(aes(label = round(Difficulty, 2), x = label_position),
size = 3, hjust = ifelse(difficulty_df$Difficulty >= 0, 0, 1)) +
# ★ ここで赤い点線を引く ★
geom_vline(xintercept = c(-3, 3), color = "red", linetype = "dashed", size = 0.2) +
scale_fill_manual(values = c("skyblue", "salmon"), guide = "none") +
labs(
title = "困難度(Difficulty)の分布(-3と3に赤い点線)",
x = "困難度",
y = "項目"
) +
theme_minimal(base_family = "Hiragino Sans")library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(識別力と困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # 識別力 a
Difficulty = ex2$est[, 2] # 困難度 b
)
# 3. 必要な項目だけフィルター(Q25, Q28, Q11, Q34)
selected_items <- param_df %>%
filter(Item %in% c("Q24", "Q26", "Q11", "Q32"))
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(selected_items), function(i) {
a <- selected_items$Discrimination[i]
b <- selected_items$Difficulty[i]
item_name <- selected_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLモデルのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データをまとめる
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成(θ = 4のときに表示)
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>%
ungroup()
# 8. ICCプロット
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) +
labs(
title = "Q24, Q26, Q11, Q32 の ICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none")library(irt)
library(ggplot2)
library(dplyr)
# 1. モデル推定(再掲)
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 2. パラメータ抽出(識別力と困難度)
param_df <- data.frame(
Item = rownames(ex2$est),
Discrimination = ex2$est[, 1], # 識別力 a
Difficulty = ex2$est[, 2] # 困難度 b
)
# 3. 必要な項目だけフィルター(Q25, Q28, Q11, Q34)
selected_items <- param_df %>%
filter(Item %in% c("Q23", "Q13", "Q34", "Q29"))
# 4. θの範囲を設定
theta_vals <- seq(-4, 4, length.out = 200)
# 5. 各項目のICCを計算
icc_list <- lapply(1:nrow(selected_items), function(i) {
a <- selected_items$Discrimination[i]
b <- selected_items$Difficulty[i]
item_name <- selected_items$Item[i]
P <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLモデルのICC公式
data.frame(
theta = theta_vals,
Probability = P,
Item = item_name
)
})
# 6. データをまとめる
icc_long <- bind_rows(icc_list)
# 7. ラベル位置データ作成(θ = 4のときに表示)
label_positions <- icc_long %>%
group_by(Item) %>%
filter(theta == max(theta)) %>%
ungroup()
# 8. ICCプロット
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1.2) +
geom_text(
data = label_positions,
aes(label = Item),
hjust = -0.1,
vjust = 0,
size = 3,
show.legend = FALSE
) +
scale_y_continuous(limits = c(0, 1)) +
labs(
title = "Q23, Q13, Q34, Q29 の ICC",
x = expression(theta),
y = "正答確率"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme(legend.position = "none")標準誤差(識別力)の範囲
0.1 〜 0.4(識別力
a の標準誤差)
(出典:芝祐順編『項目反応理論』p.34)
library(irt)
library(ggplot2)
library(dplyr)
# モデル推定
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 識別力の標準誤差(標準偏差)を取り出す
disc_se <- ex2$se[, 1] # 2列目が識別力SE
# 項目名を取得
item_names <- rownames(ex2$est)
# データフレームに変換して、小さい順に並べ替え
disc_se_df <- data.frame(
Item = item_names,
Difficulty_SE = disc_se
) %>%
arrange(Difficulty_SE) %>%
mutate(Item = factor(Item, levels = Item)) # 並び順を反映
# ラベルを棒グラフより少し右にずらすためオフセット作成
disc_se_df <- disc_se_df %>%
mutate(label_position = Difficulty_SE + 0.02)
# グラフ描画
ggplot(disc_se_df, aes(x = Difficulty_SE, y = Item)) +
geom_bar(stat = "identity", fill = "darkgreen") +
geom_text(aes(x = label_position, label = round(Difficulty_SE, 3)),
hjust = 0, size = 4) + # hjust=0で左寄せ
geom_vline(xintercept = c(0.2, 0.5), color = "red", linetype = "dashed", size = 0.4) +
labs(
title = "識別力の標準誤差(SE)の値順に並べた項目",
x = "識別力の標準誤差",
y = "項目"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme_bw(base_family = "HiraKakuProN-W3")| 標準誤差の規模 | 項目例 | 評価 |
| 小さい(安定) | Q8〜Q34 | 安心して使える |
| 大きい(不安定) | Q28, Q15, Q27 | 注意。改善または除外を検討 |
標準誤差(困難度)の範囲
0.2 〜 0.5(困難度 b
の標準誤差)
(出典:芝祐順編『項目反応理論』p.34)
library(irt)
library(ggplot2)
library(dplyr)
# モデル推定
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 困難度の標準誤差(標準偏差)を取り出す
disc_se <- ex2$se[, 2] # 1列目が困難度の標準誤差
# 項目名を取得
item_names <- rownames(ex2$est)
# データフレームに変換して、小さい順に並べ替え
disc_se_df <- data.frame(
Item = item_names,
Discrimination_SE = disc_se
) %>%
arrange(Discrimination_SE) %>%
mutate(Item = factor(Item, levels = Item)) # 並び順をグラフに反映
# ★ ラベルを棒グラフより少し右にずらすためにオフセットを作成
disc_se_df <- disc_se_df %>%
mutate(label_position = Discrimination_SE + 0.02) # 0.02だけ右にずらす
# グラフ描画(横向き棒グラフ:左小 → 右大)
ggplot(disc_se_df, aes(x = Discrimination_SE, y = Item)) +
geom_bar(stat = "identity", fill = "purple") +
geom_text(aes(x = label_position, label = round(Discrimination_SE, 3)),
hjust = 0, size = 4) + # ★hjust=0で左寄せ
# ★ ここで赤い点線を引く ★
geom_vline(xintercept = c(0.2, 0.5), color = "red", linetype = "dashed", size = 0.4) +
labs(
title = "困難度の標準誤差(SE)の値順に並べた項目",
x = "困難度の標準誤差",
y = "項目"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme_bw(base_family = "HiraKakuProN-W3") # 文字化け対策その項目がほぼ全員正答 or 誤答
サンプルサイズが少ない
受験者の能力分布と項目難易度がずれている
Q24の正答率・・・21%
Q26の正答率・・・33%
Q24, Q26, Q23, Q13, Q11, Q32 を除いて、可視化してみる
library(irt)
library(ggplot2)
library(dplyr)
# モデル推定
ex2 <- est(resp = df2[, 2:37],
model = "2PL",
engine = "ltm")
# 困難度の標準誤差(標準偏差)を取り出す
disc_se <- ex2$se[, 2] # 2列目が困難度の標準誤差
# 項目名を取得
item_names <- rownames(ex2$est)
# データフレームに変換して、小さい順に並べ替え
disc_se_df <- data.frame(
Item = item_names,
Discrimination_SE = disc_se
) %>%
filter(!(Item %in% c("Q24", "Q26", "Q23", "Q13", "Q11", "Q32"))) %>% # ★ここで除外
arrange(Discrimination_SE) %>%
mutate(Item = factor(Item, levels = Item)) # 並び順をグラフに反映
# ラベルを棒グラフより少し右にずらすためにオフセットを作成
disc_se_df <- disc_se_df %>%
mutate(label_position = Discrimination_SE + 0.02)
# グラフ描画(横向き棒グラフ:左小 → 右大)
ggplot(disc_se_df, aes(x = Discrimination_SE, y = Item)) +
geom_bar(stat = "identity", fill = "purple") +
geom_text(aes(x = label_position, label = round(Discrimination_SE, 3)),
hjust = 0, size = 4) +
geom_vline(xintercept = c(0.2, 0.5), color = "red", linetype = "dashed", size = 0.4) +
labs(
title = "困難度の標準誤差の値順に並べた項目(Q24, Q26, Q23, Q13, Q11, Q32を除外)",
x = "困難度の標準誤差",
y = "項目"
) +
theme_minimal(base_family = "Hiragino Sans") +
theme_bw(base_family = "HiraKakuProN-W3")| 標準誤差の規模 | 項目例 | 評価 |
| 小さい(安定) | Q20〜Q6など | 安心して使える |
| 中程度(不安定) | Q27〜Q34 | 除外を検討 |
| 大きい(推定不可) | Q24, Q26, Q23, Q13, Q11, Q32 | 除外 |
適切な識別力、困難度、標準誤差
0.3 〜 2.0(識別力)
−3 〜
3(困難度)
0.1 〜 0.4(識別力 a
の標準誤差)
0.2 〜 0.5(困難度 b の標準誤差)
(出典:芝祐順編『項目反応理論』p.34)
library(dplyr)
# --- estとseを読み込み(推定済みex2を使用)---
est <- ex2$est
se <- ex2$se
# --- データフレーム作成(列番号付き)---
irt_result <- data.frame(
Col_No = 1:length(item_names), # 列番号
Item = item_names, # 項目番号
a = est[, 1], # 識別力
b = est[, 2], # 困難度
SE_a = se[, 1], # 識別力の標準誤差
SE_b = se[, 2] # 困難度の標準誤差
)
# --- 判断と理由を付与 ---
irt_result <- irt_result %>%
mutate(
# 判断
Judgment = case_when(
a < 0.3 | a > 2 |
b < -3 | b > 3 |
SE_a < 0.1 | SE_a > 0.4 |
SE_b < 0.2 | SE_b > 0.5 ~ "検討or削除",
TRUE ~ "問題ない"
),
# 理由
Reason = case_when(
a < 0.3 ~ "aが低",
a > 2 ~ "aが高",
b < -3 ~ "bが低",
b > 3 ~ "bが高",
SE_a < 0.1 ~ "SE_aが小",
SE_a > 0.4 ~ "SE_aが大",
SE_b < 0.2 ~ "SE_bが小",
SE_b > 0.5 ~ "SE_bが大",
TRUE ~ ""
)
) %>%
mutate(
a = round(a, 3),
b = round(b, 3),
SE_a = round(SE_a, 3),
SE_b = round(SE_b, 3)
) %>%
arrange(factor(Judgment, levels = c("検討or削除", "問題ない")))library(ltm) # IRTモデル推定用パッケージ
# 1. 問題ない項目だけ選択
items_ok <- irt_result %>%
filter(Judgment == "問題ない") %>%
pull(Item) # Item名だけ取り出す
# 2. 元データから該当項目だけ抜き出し
# ※ここで元データ(ex2推定時に使ったデータフレーム)が必要です
# 例)df2とする(あなたの環境に合わせて読み替えてね)
df2_selected <- df2[, items_ok]
# 3. 問題ない項目だけでIRT再推定(2PLモデル)
mod_ok <- ltm(df2_selected ~ z1, IRT.param = TRUE)
# 4. ICCを描画
plot(mod_ok, legend = TRUE, cex = 0.6)library(ltm) # IRTモデル推定用パッケージ
# 1. 問題ない項目だけ選択
items_ok <- irt_result %>%
filter(Judgment == "検討or削除") %>%
pull(Item) # Item名だけ取り出す
# 2. 元データから該当項目だけ抜き出し
# ※ここで元データ(ex2推定時に使ったデータフレーム)が必要です
# 例)df2とする(あなたの環境に合わせて読み替えてね)
df2_selected <- df2[, items_ok]
# 3. 問題ない項目だけでIRT再推定(2PLモデル)
mod_ok <- ltm(df2_selected ~ z1, IRT.param = TRUE)
# 4. ICCを描画
plot(mod_ok, legend = TRUE, cex = 0.6)・項目が能力をどれだけ区別できるかを示すパラメータ
適切な識別力 a の大きさ
0.3 〜
2.0
(出典:芝祐順編『項目反応理論』p.34)
| 判断 | 基準(識別力) | 説明 |
| 削除すべき | a ≤ 0.3 or a ≥ 2.5 |
情報なし or 特定範囲だけ超鋭敏すぎ |
| 検討 | 0.3 < a < 0.6
or2.0 ≤ a < 2.5 |
即削除ではない |
| 問題なし | 0.6 ≤ a < 2.0 |
十分な情報を提供する標準的な範囲 |
library(dplyr)
est <- ex2$est
# --- データフレーム作成(識別力だけ使う) ---
irt_result <- data.frame(
Item = item_names,
Disc = est[, 1]
)
# --- Judgment(識別力だけで判断) ---
irt_result <- irt_result %>%
mutate(
Judgment = case_when(
Disc <= 0.3 | Disc >= 2.5 ~ "削除すべき",
(Disc > 0.3 & Disc < 0.6) | (Disc >= 2.0 & Disc < 2.5) ~ "検討",
Disc >= 0.6 & Disc < 2.0 ~ "問題なし",
TRUE ~ NA_character_ # 念のため(どれにも該当しないケース)
)
) %>%
mutate(
Disc = round(Disc, 3) # 小数第3位に丸め
) %>%
arrange(factor(Judgment, levels = c("削除すべき", "検討", "問題なし")))library(dplyr)
library(ggplot2)
library(tidyr)
# --- 2. 推定結果をまとめる ---
est <- ex2$est # パラメータ推定結果
irt_result <- data.frame(
Row_No = 1:length(item_names),
Item = item_names,
Disc = est[, 1], # 識別力
Diff = est[, 2] # 困難度
)
# --- 3. Judgment付与 ---
irt_result <- irt_result %>%
mutate(
Judgment = case_when(
Disc <= 0.3 | Disc >= 2.5 ~ "削除すべき",
(Disc > 0.3 & Disc < 0.6) | (Disc >= 2.0 & Disc < 2.5) ~ "検討",
Disc >= 0.6 & Disc < 2.0 ~ "問題なし",
TRUE ~ NA_character_
)
) %>%
mutate(
Disc = round(Disc, 3),
Diff = round(Diff, 3)
) %>%
arrange(factor(Judgment, levels = c("削除すべき", "検討", "問題なし")))
# --- 4. 問題なし項目だけ選ぶ ---
items_to_plot <- irt_result %>%
filter(Judgment == "問題なし")
# --- 5. θの範囲設定 ---
theta_vals <- seq(-4, 4, length.out = 100)
# --- 6. 各項目ごとにICCを計算 ---
icc_list <- lapply(1:nrow(items_to_plot), function(i) {
a <- items_to_plot$Disc[i] # 識別力
b <- items_to_plot$Diff[i] # 困難度
P_theta <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PL ICC式
data.frame(
theta = theta_vals,
Probability = P_theta,
Item = items_to_plot$Item[i]
)
})
# --- 7. ICCデータ結合 ---
icc_long <- bind_rows(icc_list)
# --- 8. ラベル位置データ作成(θ=-1付近+分散)---
label_positions <- icc_long %>%
group_by(Item) %>%
filter(abs(theta - (-1)) == min(abs(theta - (-1)))) %>%
ungroup()
# θを分散させる(少しずつずらす)
n_labels <- nrow(label_positions)
theta_offsets <- seq(-0.5, 0.5, length.out = n_labels) # -0.5〜0.5の範囲で均等にオフセット
label_positions <- label_positions %>%
arrange(Item) %>% # 項目番号順(必要に応じて変更)
mutate(theta = theta + theta_offsets) # 少しずつθをずらす
# --- 9. ggplotでICC曲線+ラベル描画 ---
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1) +
geom_text(
data = label_positions,
aes(label = Item),
vjust = -0.8, # 曲線の上に配置
size = 3,
show.legend = FALSE
) +
labs(
title = "問題なし項目のICC曲線(ラベル重ならず)",
x = "θ(能力値)",
y = "正答確率"
) +
theme_minimal() +
theme(
text = element_text(family = "Hiragino Sans"), # フォント(環境に合わせて変えてもOK)
legend.position = "none" # 凡例を非表示
)library(dplyr)
library(ggplot2)
library(tidyr)
# --- 2. 推定結果をまとめる ---
est <- ex2$est # パラメータ推定結果
irt_result <- data.frame(
Row_No = 1:length(item_names),
Item = item_names,
Disc = est[, 1], # 識別力
Diff = est[, 2] # 困難度
)
# --- 3. Judgment付与 ---
irt_result <- irt_result %>%
mutate(
Judgment = case_when(
Disc <= 0.3 | Disc >= 2.5 ~ "削除すべき",
(Disc > 0.3 & Disc < 0.6) | (Disc >= 2.0 & Disc < 2.5) ~ "検討",
Disc >= 0.6 & Disc < 2.0 ~ "問題なし",
TRUE ~ NA_character_
)
) %>%
mutate(
Disc = round(Disc, 3),
Diff = round(Diff, 3)
) %>%
arrange(factor(Judgment, levels = c("削除すべき", "検討", "問題なし")))
# --- 4. 問題なし項目だけ選ぶ ---
items_to_plot <- irt_result %>%
filter(Judgment == "検討")
# --- 5. θの範囲設定 ---
theta_vals <- seq(-4, 4, length.out = 100)
# --- 6. 各項目ごとにICCを計算 ---
icc_list <- lapply(1:nrow(items_to_plot), function(i) {
a <- items_to_plot$Disc[i] # 識別力
b <- items_to_plot$Diff[i] # 困難度
P_theta <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PL ICC式
data.frame(
theta = theta_vals,
Probability = P_theta,
Item = items_to_plot$Item[i]
)
})
# --- 7. ICCデータ結合 ---
icc_long <- bind_rows(icc_list)
# --- 8. ラベル位置データ作成(θ=-1付近+分散)---
label_positions <- icc_long %>%
group_by(Item) %>%
filter(abs(theta - (-1)) == min(abs(theta - (-1)))) %>%
ungroup()
# θを分散させる(少しずつずらす)
n_labels <- nrow(label_positions)
theta_offsets <- seq(-0.5, 0.5, length.out = n_labels) # -0.5〜0.5の範囲で均等にオフセット
label_positions <- label_positions %>%
arrange(Item) %>% # 項目番号順(必要に応じて変更)
mutate(theta = theta + theta_offsets) # 少しずつθをずらす
# --- 9. ggplotでICC曲線+ラベル描画 ---
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1) +
geom_text(
data = label_positions,
aes(label = Item),
vjust = -0.8, # 曲線の上に配置
size = 3,
show.legend = FALSE
) +
labs(
title = "検討項目のICC曲線",
x = "θ(能力値)",
y = "正答確率"
) +
theme_minimal() +
theme(
text = element_text(family = "Hiragino Sans"), # フォント(環境に合わせて変えてもOK)
legend.position = "none" # 凡例を非表示
)library(dplyr)
library(ggplot2)
library(tidyr)
# --- 2. 推定結果をまとめる ---
est <- ex2$est # パラメータ推定結果
irt_result <- data.frame(
Row_No = 1:length(item_names),
Item = item_names,
Disc = est[, 1], # 識別力
Diff = est[, 2] # 困難度
)
# --- 3. Judgment付与 ---
irt_result <- irt_result %>%
mutate(
Judgment = case_when(
Disc <= 0.3 | Disc >= 2.5 ~ "削除すべき",
(Disc > 0.3 & Disc < 0.6) | (Disc >= 2.0 & Disc < 2.5) ~ "検討",
Disc >= 0.6 & Disc < 2.0 ~ "問題なし",
TRUE ~ NA_character_
)
) %>%
mutate(
Disc = round(Disc, 3),
Diff = round(Diff, 3)
) %>%
arrange(factor(Judgment, levels = c("削除すべき", "検討", "問題なし")))
# --- 4. 問題なし項目だけ選ぶ ---
items_to_plot <- irt_result %>%
filter(Judgment == "削除すべき")
# --- 5. θの範囲設定 ---
theta_vals <- seq(-4, 4, length.out = 100)
# --- 6. 各項目ごとにICCを計算 ---
icc_list <- lapply(1:nrow(items_to_plot), function(i) {
a <- items_to_plot$Disc[i] # 識別力
b <- items_to_plot$Diff[i] # 困難度
P_theta <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PL ICC式
data.frame(
theta = theta_vals,
Probability = P_theta,
Item = items_to_plot$Item[i]
)
})
# --- 7. ICCデータ結合 ---
icc_long <- bind_rows(icc_list)
# --- 8. ラベル位置データ作成(θ=-1付近+分散)---
label_positions <- icc_long %>%
group_by(Item) %>%
filter(abs(theta - (-1)) == min(abs(theta - (-1)))) %>%
ungroup()
# θを分散させる(少しずつずらす)
n_labels <- nrow(label_positions)
theta_offsets <- seq(-0.5, 0.5, length.out = n_labels) # -0.5〜0.5の範囲で均等にオフセット
label_positions <- label_positions %>%
arrange(Item) %>% # 項目番号順(必要に応じて変更)
mutate(theta = theta + theta_offsets) # 少しずつθをずらす
# --- 9. ggplotでICC曲線+ラベル描画 ---
ggplot(icc_long, aes(x = theta, y = Probability, color = Item)) +
geom_line(size = 1) +
geom_text(
data = label_positions,
aes(label = Item),
vjust = -0.8, # 曲線の上に配置
size = 3,
show.legend = FALSE
) +
labs(
title = "削除すべき項目のICC曲線",
x = "θ(能力値)",
y = "正答確率"
) +
theme_minimal() +
theme(
text = element_text(family = "Hiragino Sans"), # フォント(環境に合わせて変えてもOK)
legend.position = "none" # 凡例を非表示
)最尤推定法の基本的な考え方
・学力 θ の候補値を −3 から 3 まで 0.1
ごとに調べる
・どの θ
のときに「そのパターンの回答が起こる可能性(尤度)」が最も高くなるかを探す
・その「最も可能性が高いθ」が、学力(潜在特性)の推定値
学力θを推定する確率計算
ltmパッケージの中に入っているデータを使う
• テスト結果を採点
受験者数: 220人
項目数:36項目
正答なら1、誤答なら0
irt_was.csv) を読み取った
df2 を使う[1] 220 38
# 2PLモデルによるIRT分析(36項目に限定)
mod <- ltm(df2[, 2:37] ~ z1, IRT.param = TRUE)
# 能力値 θ の範囲指定
theta_vals <- seq(-3, 3, by = 0.1)
# モデルから項目パラメーター(識別力 a、困難度 b)を抽出
coefs <- coef(mod) # 戻り値は列1 = Dffclt (b), 列2 = Discr (a)
# 正答確率を格納するデータフレームの作成
icc_df <- data.frame(theta = theta_vals)
# 各項目に対して正答確率を計算(2PLモデルの公式)
for (i in 1:nrow(coefs)) {
b <- coefs[i, 1] # 困難度 b
a <- coefs[i, 2] # 識別力 a
P_theta <- 1 / (1 + exp(-a * (theta_vals - b))) # 2PLのICC式
icc_df[[paste0("Q", i)]] <- round(P_theta, 4)
}テスト情報関数 ・2パラメタ・ロジスティック・モデルの場合のテスト情報量は次の式で表せる
\[I(\theta) = 1.7^2\sum_{j=1}^na_j^2P_j(\theta)Q_j(\theta)\]
| 変数 | 内容 |
|---|---|
| \(I(θ)\) | テスト情報量 |
| 1.7 | 定数 |
| \(a_j\) | 項目\(j\) の識別力 |
| \(P_j(\theta)\) | 学力θに応じた項目 \(j\) に正答する確率 |
| \(Q_j(\theta)\) | 学力θに応じた項目 \(j\) に誤答する確率 |
学力θごとに計算したテスト情報量
→ テスト情報曲線 (Test Information Curve,TIC)
で可視化する
「テストがどの能力レベル(θ)でどれくらい正確に測れているか」を可視化できる
• 潜在特性値の値毎にテスト情報量を計算しプロットする
tif関数を使ってテスト情報量を計算
→ plot関数で TIC を作成
様々な潜在特性値\(θ\)(能力)におけるテスト情報量(Information)が I
irtoysパッケージの
tif()関数を使って計算する
II <- irtoys::tif(ip = ex2$est) # データに対し2PLMを仮定
# x: tif関数で推定した結果を指定する引数
plot(x = II) # ip: テストに含まれる各項目の項目パラメーターを指定する引数 ・横軸・・・潜在特性値\(θ\)(学力)
・縦軸・・・テスト情報量(測定の精度=標準誤差の逆数)
・実線・・・テスト情報曲線
→ 当該潜在特性値におけるテスト情報量をつなぎ合わせたもの
テスト情報曲線 (TIC) でわかること
1.
どの能力レベルを正確に測れているか?
・情報量が高いところ → その学力θレベルでテストが精度が高い
→ \(\theta =
−2\)付近の情報量が最も高い
→ \(\theta =
−2\)付近のレベルでテストが高精度
・情報量が低いところ
→ その学力θレベルではテストの精度が低い
→ \(\theta =
4\)の情報量が最も低い
→ \(\theta =
4\)のレベルでテストが低精度
例:TICがθ = 0の周辺で高ければ
→「平均的な人を測るのに最適なテスト」だといえる
2.
テストの設計意図が見える
・TICがどこで山になるかを見ることで、そのテストがどんな対象向けかが分かる
・TICが\(\theta =
−2\)付近で山になっている
→ このテストは比較的能力の低い人向け
・TICがどこで山になるかを見ることで
→ そのテストがどんな対象向けかが分かる
| TICの山の位置 | 意味 | 対象 |
|---|---|---|
| θ = 0 周辺 | 平均均的な受験者向け | 一般的な学力テスト |
| θ > 0(右寄り) | 高能力者向け | 難関資格・上級試験 |
| θ < 0(左寄り) | 初級者・低能力者向け | 基礎力診断など |
・ここではTICの山の位置が左より
→ 平均均的な受験者向けだとわかる
3.
信頼性の高さ(精度)もわかる
・情報量が高い=その範囲の 標準誤差(SE)が小さい
・標準誤差との関係:
\[SE(\theta) = \frac{1}{\sqrt{{I(\theta)}}}\]
・つまり、情報量が大きいと \(\theta\) の推定がブレにくい(= 信頼できる)
4. テスト情報量の基準を設定する:4以上
・例えば、テスト情報量の基準を「4以上」と設定する
→ 情報精度の基準を満たしている学力θの範囲がわかる
項目適合度の結果のポイント
どの潜在特性値 \(\theta\)
の値で、情報量が最大になるか
・潜在特性値が −2 の辺りでテスト情報量が最大
⇒ 潜在特性値\(θ\)(能力)が低い( −2
の辺り )受験者の推定精度が最も高い
mlebme()mlebme関数を利用して潜在特性値を推定mlebme関数はirtoysパッケージの中に入っている関数head(mlebme(resp = df2[, 2:37], # テストデータを指定
ip = ex2$est, # データに対し2PLMを仮定
method = "BM")) # 最尤推定法 (ML) による潜在特性値の推定を指定 est sem n
[1,] -0.8767052 0.3681238 36
[2,] -0.6930227 0.3818157 36
[3,] -0.8473560 0.3703335 36
[4,] -1.4528580 0.3200674 36
[5,] -0.4407062 0.4012669 36
[6,] 0.7551844 0.5320713 36
resp: テストデータを指定する引数ip:
テストに含まれる各項目の項目パラメーターを指定する引数ex2$est と指定method: どの推定法を用いて潜在特性値を推定するかML と指定BM と指定est)sem)n)irf() &
cor()一次元性の仮定 各項目の正誤が、潜在特性値 \(\theta\) の値の大小によってのみばらつく
• 局所独立性の検討は \(Q_3\)統計量に基づいて行われることが多い
• \(Q_3\)統計量とは、各項目への回答(観測値)からその期待値を引き
→ 得られた残差得点間の相関を求めることで得られる
- \(Q_3\)統計量は、各項目への反応(=
観測値) からその期待値(=
項目反応モデルにより計算される正答確率)を引き
→ 得られた残差得点間の相関を求めることで得られる統計量
- その絶対値が 0 に近いほど、項目反応間に局所独立性を仮定できる
• たとえば今の場合、item1 の残差得点\(d_1\)は次の式で表せる
\[d_1 = u_1 - \hat{P_1(\theta)}\]
Q1
への解答結果(正答なら1、誤答なら0)irf関数を利用して正答確率 ($f)
を推定• irf関数では2PLMを仮定
• ex1$est と指定
→ データに対し2PLMを仮定したときの項目パラメーターの推定値を各項目の項目パラメーターとして指定
• theta.est[, 1] と指定
→ データに対し2PLMを仮定したときの潜在特性の推定値を指定
⇒ 結果はP1として保存
- P1の中はこんな感じ(かなり長い)
| 変数 | 内容 |
|---|---|
| $x | 各受験者の潜在特性値\(\theta\)(能力) |
| $f | 正答確率の推定値 |
| 行 | 受験者 (220名) |
| 列 | 項目 (Q1〜Q36) |
1 ≦ j ≦36)P1$fと指定することで,正答確率の推定値が抽出される(df2, 2:37) から正答確率を引いた残差得点を
\(d\) に保存 Q1 Q2 Q3 Q4 Q5 Q6 Q7
1 0.3764938 -0.8020783 0.1631724 -0.1601448 -0.3495679 -0.5014304 0.2435011
2 0.3413914 -0.8394026 -0.8595188 -0.1913116 -0.3623292 0.4799635 0.2159193
Q8 Q9 Q10 Q11 Q12 Q13 Q14
1 -0.5156387 -0.3963863 -0.2938277 -0.2133097 0.5882151 0.4192013 -0.1394617
2 -0.5255719 0.5577902 0.6729046 -0.2192435 0.5543485 -0.5846924 0.8477109
Q15 Q16 Q17 Q18 Q19 Q20 Q21
1 0.1400500 0.2853420 -0.2009591 0.3995311 0.5077143 0.6791613 0.3724295
2 -0.9091997 -0.7505344 0.7731181 0.3395556 0.4853587 0.5949887 -0.6836084
Q22 Q23 Q24 Q25 Q26 Q27 Q28
1 0.4285537 0.8251662 -0.2088083 -0.3641840 -0.3244871 0.10250561 0.013926729
2 -0.6141168 0.8273212 -0.2098727 -0.3511968 -0.3256762 0.07911754 0.006752633
Q29 Q30 Q31 Q32 Q33 Q34 Q35
1 0.08805911 0.7458928 -0.5750497 -0.3306807 -0.7512059 -0.93752709 -0.7731963
2 0.07738319 -0.2766025 0.3661200 0.6631874 0.2133131 0.05396073 0.2023193
Q36
1 -0.7868388
2 0.1822417
受験者1のQ1 に関する残差得点
\(d_{11}\)をチェック
・例えば、受験者1のQ1 に関する残差得点 \(d_1\) は 0.3764938
・受験者1の Q1 への回答 \(u_{ij}
= u_{11}\) を確認してみる
# A tibble: 1 × 1
ID
<dbl>
1 1
Q1 への回答は 1(正答) ID
1 0.6235062
cor関数を利用して \(Q_3\) 統計量の値を計算 Q1 Q2 Q3 Q4 Q5
Q1 1.000000000 0.009886907 0.034121554 0.03204650 -0.022418404
Q2 0.009886907 1.000000000 0.317732473 -0.08574863 0.020644169
Q3 0.034121554 0.317732473 1.000000000 0.01146813 0.045591880
Q4 0.032046504 -0.085748632 0.011468127 1.00000000 0.075721918
Q5 -0.022418404 0.020644169 0.045591880 0.07572192 1.000000000
Q6 0.007891653 -0.020275002 -0.017514937 0.08361975 0.171859994
Q7 0.259282965 -0.133855055 0.193419751 0.05437894 0.055906854
Q8 0.023542930 -0.006175132 0.133085698 0.11080293 0.107717436
Q9 0.208310513 0.019541557 0.066953602 -0.05410054 0.034347951
Q10 -0.053825803 0.025219185 -0.050113633 -0.01950422 -0.025465340
Q11 0.104439715 0.059988111 -0.059023864 -0.01287251 -0.115062269
Q12 -0.069880684 -0.121055322 0.015923937 0.02265305 -0.065214653
Q13 0.006596707 -0.067929669 0.065307629 0.04603092 -0.024677731
Q14 -0.123471683 0.038626994 -0.088242065 0.05058035 0.044342004
Q15 -0.187588925 -0.192223406 -0.112931026 -0.03449322 0.047847993
Q16 -0.065964071 0.148826052 0.059084916 -0.10640883 0.048125580
Q17 -0.125988256 -0.138459632 -0.030708951 0.02089458 0.105634259
Q18 -0.117934891 -0.215137661 -0.050055431 0.02008157 -0.034400696
Q19 -0.042349813 -0.074286510 -0.013183026 0.08005636 -0.044317227
Q20 0.089713531 -0.100337431 -0.137220556 -0.05228693 -0.026598320
Q21 0.206744556 0.045103252 0.067822287 -0.14381815 -0.109519482
Q22 -0.224841515 -0.088713793 0.007106703 0.00526165 0.015919306
Q23 0.043509223 -0.070608449 0.035077077 -0.06147393 -0.106388690
Q24 0.012253545 0.011727148 0.001136900 0.05220205 -0.033701332
Q25 -0.184731860 0.079612724 -0.071704436 0.03408949 -0.087477341
Q26 -0.154967373 -0.086031330 -0.062776133 0.06173078 0.093433018
Q27 -0.163197267 -0.137776365 0.002154665 -0.08487991 -0.122926616
Q28 -0.187230268 0.061033239 -0.111605793 -0.03488348 -0.166869359
Q29 -0.068083714 -0.109336493 -0.007862368 -0.07246145 -0.026042571
Q30 0.030106542 -0.201782640 -0.105756970 0.01136671 0.023234319
Q31 0.030706412 0.079325789 -0.217054018 -0.17931599 -0.023370849
Q32 0.023349267 -0.039722366 -0.103998766 0.10300000 0.001096352
Q33 -0.075554059 -0.075920713 -0.087435195 -0.01217830 -0.052734491
Q34 -0.068405742 -0.013609937 -0.048448079 -0.05144967 -0.174253595
Q35 -0.230976571 0.038050329 0.012540627 -0.11322961 -0.032161768
Q36 -0.088632485 0.180440721 -0.233642934 -0.23914696 -0.053835199
Q6 Q7 Q8 Q9 Q10
Q1 0.007891653 0.259282965 0.0235429299 0.208310513 -0.053825803
Q2 -0.020275002 -0.133855055 -0.0061751319 0.019541557 0.025219185
Q3 -0.017514937 0.193419751 0.1330856982 0.066953602 -0.050113633
Q4 0.083619752 0.054378939 0.1108029337 -0.054100540 -0.019504222
Q5 0.171859994 0.055906854 0.1077174358 0.034347951 -0.025465340
Q6 1.000000000 -0.140294600 0.0699840399 0.087207759 -0.020695027
Q7 -0.140294600 1.000000000 0.0948314628 0.064404871 -0.023663912
Q8 0.069984040 0.094831463 1.0000000000 -0.085170351 -0.117841219
Q9 0.087207759 0.064404871 -0.0851703507 1.000000000 -0.078668991
Q10 -0.020695027 -0.023663912 -0.1178412186 -0.078668991 1.000000000
Q11 -0.164143717 -0.110141493 -0.1548236524 -0.078552088 -0.017609863
Q12 -0.145540548 -0.126604378 -0.0159544118 0.010083255 -0.003034357
Q13 0.018133965 0.117912749 -0.0684955662 0.008986200 -0.060879465
Q14 -0.106378735 -0.066357408 -0.1049457200 0.051559876 0.208205192
Q15 -0.132096698 -0.023591737 -0.0471786107 -0.182609213 -0.078644845
Q16 -0.112140877 0.048761829 0.0315694218 -0.028769065 0.008935241
Q17 -0.108526818 0.006101086 -0.0428148063 -0.061125795 0.004969302
Q18 0.065298568 -0.066404898 0.0180952265 -0.057961006 -0.190419720
Q19 0.051631430 0.090103398 -0.1364626145 -0.042495498 -0.061669890
Q20 0.060383968 -0.071822947 0.0915433737 -0.169671204 -0.145621562
Q21 -0.040293453 0.154152753 -0.0092376612 0.072168602 -0.158168578
Q22 0.099799568 -0.060743930 -0.0811958426 -0.143751454 0.088217877
Q23 -0.081254334 0.068457904 -0.0568037216 -0.062129096 0.046325247
Q24 0.011589912 0.031428589 0.0029310995 0.056204002 -0.130926120
Q25 0.023226209 -0.102309489 -0.0301042299 -0.105153360 0.034539943
Q26 0.075275843 -0.023846631 0.0155331299 0.103550844 -0.103240811
Q27 -0.180994174 -0.051723433 -0.0863186246 -0.143704130 0.003949235
Q28 0.079706784 -0.058429068 0.0471657005 0.030711936 0.056478690
Q29 -0.038908008 -0.116288848 0.0173776712 -0.051279941 -0.151326181
Q30 -0.092357134 -0.032637477 0.0438337661 0.075657369 -0.137503610
Q31 -0.092200886 -0.160488266 -0.1031664510 -0.032744618 0.093132185
Q32 0.009361335 -0.027806697 -0.0225877502 0.028363739 0.071103164
Q33 0.029218601 -0.176797110 0.0002102769 -0.114417709 0.059726742
Q34 0.049427170 0.046074375 -0.0552229930 -0.001893341 0.007064854
Q35 -0.005126877 -0.211961241 0.0205869432 -0.081962235 0.020231377
Q36 0.046336997 -0.120572563 -0.1167839009 -0.186826982 0.030329647
Q11 Q12 Q13 Q14 Q15
Q1 0.104439715 -0.069880684 0.006596707 -0.123471683 -0.18758892
Q2 0.059988111 -0.121055322 -0.067929669 0.038626994 -0.19222341
Q3 -0.059023864 0.015923937 0.065307629 -0.088242065 -0.11293103
Q4 -0.012872506 0.022653050 0.046030922 0.050580349 -0.03449322
Q5 -0.115062269 -0.065214653 -0.024677731 0.044342004 0.04784799
Q6 -0.164143717 -0.145540548 0.018133965 -0.106378735 -0.13209670
Q7 -0.110141493 -0.126604378 0.117912749 -0.066357408 -0.02359174
Q8 -0.154823652 -0.015954412 -0.068495566 -0.104945720 -0.04717861
Q9 -0.078552088 0.010083255 0.008986200 0.051559876 -0.18260921
Q10 -0.017609863 -0.003034357 -0.060879465 0.208205192 -0.07864484
Q11 1.000000000 0.027320010 0.065748164 -0.094486634 0.06554182
Q12 0.027320010 1.000000000 0.052617014 0.108252984 -0.01863240
Q13 0.065748164 0.052617014 1.000000000 -0.157073025 0.09797507
Q14 -0.094486634 0.108252984 -0.157073025 1.000000000 -0.11071151
Q15 0.065541823 -0.018632396 0.097975071 -0.110711508 1.00000000
Q16 0.093484341 -0.066244049 0.006336439 -0.107227284 0.03668920
Q17 -0.028490224 0.038794226 -0.104642371 0.130970274 0.08648302
Q18 -0.065776876 -0.036146306 0.016786472 -0.146250990 0.19868159
Q19 0.127463148 -0.101394841 0.309542389 -0.245450028 0.02848397
Q20 0.110835939 -0.025467038 0.025532361 -0.155068734 -0.10609646
Q21 0.001575685 -0.077785074 -0.019877492 -0.132610610 -0.03704507
Q22 -0.057145264 -0.084625555 -0.110013501 0.043419251 0.05240642
Q23 0.007281967 -0.104003285 -0.008896153 -0.022232327 -0.10305158
Q24 -0.139887556 -0.154906672 0.040934718 -0.041065175 0.03302357
Q25 -0.033000970 0.097170242 0.124061691 -0.013516025 0.12064576
Q26 0.016757236 0.073185284 0.202544894 -0.070267105 0.04444988
Q27 0.068355839 0.034136586 -0.055848146 0.055358525 0.10029509
Q28 -0.135444034 0.021877107 0.070767023 0.050244680 -0.21210904
Q29 0.012468339 0.108038104 -0.005736872 -0.089265772 -0.05536671
Q30 -0.181588938 0.082122681 -0.009434220 -0.066045810 0.09182519
Q31 0.072655107 -0.043095849 -0.194768117 0.147985843 -0.17054781
Q32 0.085372989 -0.042099013 0.195068549 0.139047718 -0.11628357
Q33 -0.006694599 -0.009169009 0.004001498 0.051388511 -0.04769245
Q34 -0.062391398 -0.103522685 0.052817175 -0.027267785 -0.05604047
Q35 -0.059905855 -0.063281306 -0.001131171 0.088081655 -0.05083122
Q36 0.021177183 -0.048643109 -0.093935058 -0.009293623 -0.02955211
Q16 Q17 Q18 Q19 Q20
Q1 -0.065964071 -0.125988256 -0.117934891 -4.234981e-02 0.08971353
Q2 0.148826052 -0.138459632 -0.215137661 -7.428651e-02 -0.10033743
Q3 0.059084916 -0.030708951 -0.050055431 -1.318303e-02 -0.13722056
Q4 -0.106408833 0.020894576 0.020081569 8.005636e-02 -0.05228693
Q5 0.048125580 0.105634259 -0.034400696 -4.431723e-02 -0.02659832
Q6 -0.112140877 -0.108526818 0.065298568 5.163143e-02 0.06038397
Q7 0.048761829 0.006101086 -0.066404898 9.010340e-02 -0.07182295
Q8 0.031569422 -0.042814806 0.018095227 -1.364626e-01 0.09154337
Q9 -0.028769065 -0.061125795 -0.057961006 -4.249550e-02 -0.16967120
Q10 0.008935241 0.004969302 -0.190419720 -6.166989e-02 -0.14562156
Q11 0.093484341 -0.028490224 -0.065776876 1.274631e-01 0.11083594
Q12 -0.066244049 0.038794226 -0.036146306 -1.013948e-01 -0.02546704
Q13 0.006336439 -0.104642371 0.016786472 3.095424e-01 0.02553236
Q14 -0.107227284 0.130970274 -0.146250990 -2.454500e-01 -0.15506873
Q15 0.036689196 0.086483024 0.198681588 2.848397e-02 -0.10609646
Q16 1.000000000 -0.029698577 0.145523248 -1.081232e-01 -0.11500640
Q17 -0.029698577 1.000000000 0.035456809 -6.642719e-02 -0.13744892
Q18 0.145523248 0.035456809 1.000000000 -6.741981e-03 -0.07064684
Q19 -0.108123224 -0.066427194 -0.006741981 1.000000e+00 0.03555511
Q20 -0.115006396 -0.137448920 -0.070646841 3.555511e-02 1.00000000
Q21 0.118040723 -0.017578954 0.025189527 -1.138519e-01 -0.07202984
Q22 -0.084077233 0.026103238 -0.052789910 1.129208e-01 -0.09103218
Q23 -0.009491892 0.048660728 0.048793354 -1.044595e-06 0.12882612
Q24 -0.009684228 -0.041791310 0.178026755 1.464077e-02 -0.02636510
Q25 -0.020821781 -0.028339081 0.058300278 2.162773e-01 -0.03639152
Q26 -0.049645990 -0.169120813 -0.047079606 2.150177e-01 -0.03184346
Q27 -0.226380967 0.023552522 -0.074090869 -3.556374e-02 -0.02166301
Q28 0.221335455 -0.048922973 0.023114263 8.122669e-02 -0.06094474
Q29 -0.195272050 -0.083864562 -0.155523458 -7.272298e-02 0.08757880
Q30 -0.061708953 -0.022775827 0.037891617 3.245349e-02 0.04028998
Q31 -0.108526170 -0.032491871 -0.194752854 -3.878954e-02 -0.06453145
Q32 -0.121514450 -0.181096283 -0.110383633 2.090223e-01 0.03828574
Q33 -0.306257349 -0.074984765 -0.117806238 9.977867e-02 -0.02147670
Q34 -0.111903611 -0.043359241 -0.111431600 -3.941760e-02 -0.14672501
Q35 -0.061998877 0.068280768 -0.040908606 -2.429961e-01 -0.06392623
Q36 -0.100979020 -0.148475914 -0.128791389 4.311872e-03 -0.06787787
Q21 Q22 Q23 Q24 Q25
Q1 0.206744556 -0.224841515 4.350922e-02 0.012253545 -0.18473186
Q2 0.045103252 -0.088713793 -7.060845e-02 0.011727148 0.07961272
Q3 0.067822287 0.007106703 3.507708e-02 0.001136900 -0.07170444
Q4 -0.143818151 0.005261650 -6.147393e-02 0.052202053 0.03408949
Q5 -0.109519482 0.015919306 -1.063887e-01 -0.033701332 -0.08747734
Q6 -0.040293453 0.099799568 -8.125433e-02 0.011589912 0.02322621
Q7 0.154152753 -0.060743930 6.845790e-02 0.031428589 -0.10230949
Q8 -0.009237661 -0.081195843 -5.680372e-02 0.002931100 -0.03010423
Q9 0.072168602 -0.143751454 -6.212910e-02 0.056204002 -0.10515336
Q10 -0.158168578 0.088217877 4.632525e-02 -0.130926120 0.03453994
Q11 0.001575685 -0.057145264 7.281967e-03 -0.139887556 -0.03300097
Q12 -0.077785074 -0.084625555 -1.040033e-01 -0.154906672 0.09717024
Q13 -0.019877492 -0.110013501 -8.896153e-03 0.040934718 0.12406169
Q14 -0.132610610 0.043419251 -2.223233e-02 -0.041065175 -0.01351602
Q15 -0.037045069 0.052406420 -1.030516e-01 0.033023569 0.12064576
Q16 0.118040723 -0.084077233 -9.491892e-03 -0.009684228 -0.02082178
Q17 -0.017578954 0.026103238 4.866073e-02 -0.041791310 -0.02833908
Q18 0.025189527 -0.052789910 4.879335e-02 0.178026755 0.05830028
Q19 -0.113851909 0.112920847 -1.044595e-06 0.014640773 0.21627725
Q20 -0.072029835 -0.091032179 1.288261e-01 -0.026365101 -0.03639152
Q21 1.000000000 -0.007084475 1.291636e-01 0.220622731 -0.20658704
Q22 -0.007084475 1.000000000 1.042582e-01 0.038872276 0.04213179
Q23 0.129163598 0.104258237 1.000000e+00 0.027340762 -0.08885207
Q24 0.220622731 0.038872276 2.734076e-02 1.000000000 -0.09906947
Q25 -0.206587038 0.042131788 -8.885207e-02 -0.099069469 1.00000000
Q26 -0.049832890 0.156483142 -4.340173e-02 -0.040852936 0.27704549
Q27 -0.137378364 0.083337809 6.909193e-02 -0.044156533 0.05776937
Q28 -0.182944964 -0.042875722 8.423069e-02 -0.038877642 0.03732878
Q29 -0.080250133 -0.108991511 -9.687969e-02 -0.032683769 0.01261836
Q30 -0.034790291 0.002390046 -2.732291e-02 -0.006065601 -0.07934241
Q31 -0.189729575 -0.070280614 -6.048095e-02 -0.189601051 0.07145086
Q32 -0.081892040 0.040794625 -5.175579e-02 0.057092141 0.19845010
Q33 -0.258843944 -0.027085811 -4.765537e-02 -0.088544154 0.03801166
Q34 -0.027582299 -0.047692198 3.227390e-02 0.042848359 0.11581128
Q35 -0.116247412 -0.130932779 -5.525026e-02 -0.009563297 0.08013536
Q36 0.069817858 0.011721526 -1.282015e-01 -0.013320761 0.10553556
Q26 Q27 Q28 Q29 Q30
Q1 -0.15496737 -0.1631972675 -0.187230268 -0.068083714 0.030106542
Q2 -0.08603133 -0.1377763648 0.061033239 -0.109336493 -0.201782640
Q3 -0.06277613 0.0021546646 -0.111605793 -0.007862368 -0.105756970
Q4 0.06173078 -0.0848799054 -0.034883479 -0.072461455 0.011366709
Q5 0.09343302 -0.1229266158 -0.166869359 -0.026042571 0.023234319
Q6 0.07527584 -0.1809941742 0.079706784 -0.038908008 -0.092357134
Q7 -0.02384663 -0.0517234333 -0.058429068 -0.116288848 -0.032637477
Q8 0.01553313 -0.0863186246 0.047165700 0.017377671 0.043833766
Q9 0.10355084 -0.1437041297 0.030711936 -0.051279941 0.075657369
Q10 -0.10324081 0.0039492348 0.056478690 -0.151326181 -0.137503610
Q11 0.01675724 0.0683558387 -0.135444034 0.012468339 -0.181588938
Q12 0.07318528 0.0341365857 0.021877107 0.108038104 0.082122681
Q13 0.20254489 -0.0558481458 0.070767023 -0.005736872 -0.009434220
Q14 -0.07026710 0.0553585252 0.050244680 -0.089265772 -0.066045810
Q15 0.04444988 0.1002950893 -0.212109042 -0.055366713 0.091825185
Q16 -0.04964599 -0.2263809674 0.221335455 -0.195272050 -0.061708953
Q17 -0.16912081 0.0235525218 -0.048922973 -0.083864562 -0.022775827
Q18 -0.04707961 -0.0740908686 0.023114263 -0.155523458 0.037891617
Q19 0.21501774 -0.0355637431 0.081226691 -0.072722979 0.032453493
Q20 -0.03184346 -0.0216630087 -0.060944743 0.087578804 0.040289983
Q21 -0.04983289 -0.1373783637 -0.182944964 -0.080250133 -0.034790291
Q22 0.15648314 0.0833378094 -0.042875722 -0.108991511 0.002390046
Q23 -0.04340173 0.0690919303 0.084230694 -0.096879687 -0.027322912
Q24 -0.04085294 -0.0441565328 -0.038877642 -0.032683769 -0.006065601
Q25 0.27704549 0.0577693669 0.037328776 0.012618358 -0.079342413
Q26 1.00000000 -0.0145508673 0.016309250 0.032833672 -0.190435566
Q27 -0.01455087 1.0000000000 -0.081683223 0.375445898 0.001190998
Q28 0.01630925 -0.0816832231 1.000000000 -0.059032516 0.001690726
Q29 0.03283367 0.3754458979 -0.059032516 1.000000000 -0.033983811
Q30 -0.19043557 0.0011909979 0.001690726 -0.033983811 1.000000000
Q31 0.01677513 0.0009586121 -0.078585833 0.051233901 -0.060512878
Q32 0.28889853 -0.0044039029 -0.086876659 -0.040610335 -0.140414451
Q33 0.05734486 0.0177362381 -0.003594532 0.173366165 -0.062617974
Q34 0.09163023 0.0618966462 0.107842826 0.211232135 -0.019771677
Q35 0.09166825 0.1513400780 -0.004121764 0.181270500 -0.198914612
Q36 0.07734392 0.0192065930 -0.109933507 0.138863822 -0.090929431
Q31 Q32 Q33 Q34 Q35
Q1 0.0307064124 0.023349267 -0.0755540587 -0.068405742 -0.230976571
Q2 0.0793257887 -0.039722366 -0.0759207128 -0.013609937 0.038050329
Q3 -0.2170540179 -0.103998766 -0.0874351952 -0.048448079 0.012540627
Q4 -0.1793159942 0.102999997 -0.0121783004 -0.051449673 -0.113229607
Q5 -0.0233708486 0.001096352 -0.0527344909 -0.174253595 -0.032161768
Q6 -0.0922008864 0.009361335 0.0292186008 0.049427170 -0.005126877
Q7 -0.1604882657 -0.027806697 -0.1767971096 0.046074375 -0.211961241
Q8 -0.1031664510 -0.022587750 0.0002102769 -0.055222993 0.020586943
Q9 -0.0327446183 0.028363739 -0.1144177091 -0.001893341 -0.081962235
Q10 0.0931321850 0.071103164 0.0597267420 0.007064854 0.020231377
Q11 0.0726551066 0.085372989 -0.0066945992 -0.062391398 -0.059905855
Q12 -0.0430958491 -0.042099013 -0.0091690092 -0.103522685 -0.063281306
Q13 -0.1947681175 0.195068549 0.0040014982 0.052817175 -0.001131171
Q14 0.1479858426 0.139047718 0.0513885109 -0.027267785 0.088081655
Q15 -0.1705478144 -0.116283566 -0.0476924532 -0.056040472 -0.050831216
Q16 -0.1085261701 -0.121514450 -0.3062573494 -0.111903611 -0.061998877
Q17 -0.0324918706 -0.181096283 -0.0749847654 -0.043359241 0.068280768
Q18 -0.1947528543 -0.110383633 -0.1178062376 -0.111431600 -0.040908606
Q19 -0.0387895432 0.209022256 0.0997786738 -0.039417597 -0.242996112
Q20 -0.0645314462 0.038285737 -0.0214767049 -0.146725007 -0.063926230
Q21 -0.1897295750 -0.081892040 -0.2588439443 -0.027582299 -0.116247412
Q22 -0.0702806137 0.040794625 -0.0270858113 -0.047692198 -0.130932779
Q23 -0.0604809526 -0.051755787 -0.0476553743 0.032273904 -0.055250265
Q24 -0.1896010509 0.057092141 -0.0885441542 0.042848359 -0.009563297
Q25 0.0714508552 0.198450101 0.0380116588 0.115811279 0.080135363
Q26 0.0167751285 0.288898533 0.0573448559 0.091630226 0.091668248
Q27 0.0009586121 -0.004403903 0.0177362381 0.061896646 0.151340078
Q28 -0.0785858330 -0.086876659 -0.0035945316 0.107842826 -0.004121764
Q29 0.0512339006 -0.040610335 0.1733661646 0.211232135 0.181270500
Q30 -0.0605128776 -0.140414451 -0.0626179745 -0.019771677 -0.198914612
Q31 1.0000000000 0.204063923 0.1625927249 0.077579164 0.125417309
Q32 0.2040639234 1.000000000 0.0392426162 -0.119599333 0.196978889
Q33 0.1625927249 0.039242616 1.0000000000 0.197027886 0.179135980
Q34 0.0775791637 -0.119599333 0.1970278863 1.000000000 0.129715649
Q35 0.1254173086 0.196978889 0.1791359799 0.129715649 1.000000000
Q36 0.2078304454 0.045166826 0.1064891260 0.138106635 0.190943254
Q36
Q1 -0.088632485
Q2 0.180440721
Q3 -0.233642934
Q4 -0.239146959
Q5 -0.053835199
Q6 0.046336997
Q7 -0.120572563
Q8 -0.116783901
Q9 -0.186826982
Q10 0.030329647
Q11 0.021177183
Q12 -0.048643109
Q13 -0.093935058
Q14 -0.009293623
Q15 -0.029552114
Q16 -0.100979020
Q17 -0.148475914
Q18 -0.128791389
Q19 0.004311872
Q20 -0.067877872
Q21 0.069817858
Q22 0.011721526
Q23 -0.128201527
Q24 -0.013320761
Q25 0.105535561
Q26 0.077343920
Q27 0.019206593
Q28 -0.109933507
Q29 0.138863822
Q30 -0.090929431
Q31 0.207830445
Q32 0.045166826
Q33 0.106489126
Q34 0.138106635
Q35 0.190943254
Q36 1.000000000
# Q3の絶対値をとる
Q3_abs <- abs(Q3)
# 対角成分(自己相関1.0)をNAにして除外する
diag(Q3_abs) <- NA
# 絶対値が0.2以上の個数を数える
count_0.2_or_more <- sum(Q3_abs >= 0.2, na.rm = TRUE)
# 全体の要素数(対角除外後の数)
total_elements <- sum(!is.na(Q3_abs))
# 割合を計算
proportion_0.2_or_more <- count_0.2_or_more / total_elements
# 結果を表示
cat("絶対値が0.2以上の個数:", count_0.2_or_more, "\n")絶対値が0.2以上の個数: 66
割合: 0.05238095
library(ggplot2)
library(reshape2)
# Q3行列を絶対値に
Q3_abs <- abs(Q3)
diag(Q3_abs) <- NA # 対角成分除外
# meltしてロング形式に
Q3_long <- melt(Q3_abs, varnames = c("Item1", "Item2"), value.name = "Q3_value")
# 0.2超えのフラグをつける
Q3_long$Violation <- Q3_long$Q3_value > 0.2
# ヒートマップ作成
ggplot(Q3_long, aes(x = Item1, y = Item2, fill = Violation)) +
geom_tile(color = "white") +
scale_fill_manual(values = c("white", "deeppink")) +
labs(
title = "局所独立性違反ヒートマップ(ピンク=違反)",
x = "項目",
y = "項目"
) +
theme_bw(base_family = "HiraKakuProN-W3") + # 先に白背景+日本語フォント
theme(
axis.text.x = element_text(angle = 90, hjust = 1, vjust = 1), # ←ここで傾ける
axis.text.y = element_text(hjust = 1)
)library(dplyr)
library(reshape2)
# --- Q3絶対値+小数点第3位四捨五入
Q3_abs <- abs(Q3)
Q3_abs <- round(Q3_abs, 3)
diag(Q3_abs) <- NA # 対角成分はNA
# --- ロング形式に変換
Q3_long <- melt(Q3_abs, varnames = c("Item1", "Item2"), value.name = "Q3_abs")
# --- ダブりを除去するため、Item1とItem2を並び替え
Q3_long <- Q3_long %>%
filter(!is.na(Q3_abs)) %>%
mutate(Item_min = pmin(as.character(Item1), as.character(Item2)),
Item_max = pmax(as.character(Item1), as.character(Item2))) %>%
select(Item1 = Item_min, Item2 = Item_max, Q3_abs)
# --- さらに重複を除去
Q3_long <- distinct(Q3_long)
# --- 0.2以上違反だけ取り出して、大きい順に並べる
violations <- Q3_long %>%
filter(Q3_abs >= 0.2) %>%
arrange(desc(Q3_abs))局所独立性の検討のポイント
各項目の正誤が、潜在特性値 \(\theta\)
の値の大小によってのみばらつくかどうか
・Q_3 の絶対値が 0
に近いほど、項目反応間に局所独立性を仮定できる
・\(Q_3\) の値の絶対値が
0.2以上の場合 → 問題あり
→ 局所依存性の疑い(Chen & Thissen, 1997)
・\(Q_3\) の値の絶対値が 0.2以下の場合 → 問題なし
・\(Q_3\)
の値の絶対値の値を計算してみた
→ \(Q_3\)
の値の絶対値が0.2以上の個数が 66 → 問題あり
→ 局所独立性が成立していないことを示唆
→ 対策が必要
🔵 学力θで説明しきれない強い依存関係が残っている
🔵 何か別の理由で項目同士が結びついている
| 原因 | 説明・具体例 |
| 1. 内容重複 | 似たような問題が並んでいる |
| Q:「徳川家康が開いた幕府は何幕府ですか?」 | |
| Q:「江戸時代を開いたのは誰ですか?」 | |
| 2. 共通背景効果 | 同じ図表、同じ文章、同じケーススタディから複数出題している |
| ある小説の一節を読ませたあと、 | |
| Q:「主人公が怒った理由は何か?」 | |
| Q:「主人公の行動の背景にある感情は何か?」 | |
| 3. 答えを引っ張るヒント効果 | ある問題の答えが、別の問題のヒントになっている |
| Q:「植物が光合成するために必要な3つの要素は?」 | |
| Q:「光合成に必要な二酸化炭素はどこから取り入れる?」 | |
| 4. 生徒の戦略的回答 | ある問題の答えを参考にして他を推測している |
| Q:「イギリスの通貨単位は何ですか?」 | |
| Q:「1ポンドは何ペンスに相当しますか?」 | |
| 5. モデルの不適合 | 1次元で学力を説明できない(因子が2つ以上ある) |
| 英語テストで: | |
| Q1〜Q10は「文法問題」 | |
| Q11〜Q20は「リスニング問題」 | |
・\(Q_3\)はあくまで一つの基準に過ぎないので注意が必要